HAM Radio 1997/HAM Radio 1997.iso/vcls/nccomp/ncobject.pas

Pascal/Delphi Source File | 1996-04-08 | 12KB | 471 lines

unit Ncobject;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, NonClt, ExtCtrls;

{$R NCButs.res}    { Default Blank Bitmap button, Blank }
                   { Bitmaps contain two button 20 x 18 }
                   { next to each other in a 40 x 18 bitmap }
                   { Left is Up, Right is Down }

type
  TNCBlank = class(TNCComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    procedure RePaint; override;
  published
    { Published declarations }
    property Width default 20;
    property DragBy default True;
  end;

type
  TNCButton = class(TNCComponent)
  private
    { Private declarations }
    FGlyph : TBitmap;
    FButtonLock : boolean;
    FButtonUp : boolean;
    FOnClick : TNotifyEvent;
    FOnUnClick : TNotifyEvent;
    MouseOnGlyph : boolean;
    ButtonDown : boolean;     {Locked Buttons Only}
    MouseCapture : boolean;   {Normal Buttons Only}
    procedure SetGlyph(Value : TBitmap);
    procedure Paint(Up : boolean);
    procedure ButtonClicked;
    procedure ButtonUnClicked;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy;
    procedure RePaint; override;
    procedure MouseMove(MouseX, MouseY : integer); override;
    procedure LButton(ButtonState : TNCClickState); override;
  published
    { Published declarations }
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property ButtonLock: boolean read FButtonLock write FButtonLock
                                            default False;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnUnClick: TNotifyEvent read FOnUnClick write FOnUnClick;
    property Width default 20;
  end;

type
  TTextAlign = (taLeft,taCenter,taRight);
  TNCLabel = class(TNCBlank)
  private
    { Private declarations }
    FCaption : TCaption;
    FBkColor : TColor;
    FTextColor : TColor;
    FTextAlign : word;
    FFCC : boolean;
    function GetCaption : TCaption;
    procedure SetCaption(Value: TCaption);
    procedure SetFTextColor(Value : TColor);
    procedure SetFBkColor(Value : TColor);
    procedure SetTextAlign(Value : TTextAlign);
    function GetTextAlign : TTextAlign;
    procedure Paint;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    procedure RePaint; override;
  published
    { Published declarations }
    property Width default 100;
    property Caption : TCaption read GetCaption write SetCaption;
    property TextColor : TColor read FTextColor write SetFTextColor
                                default clCaptionText;
    property BackgroundColor : TColor read FBkColor write SetFBkColor
                                 default clActiveCaption;
    property TextAlign : TTextAlign read GetTextAlign write SetTextAlign
                                    default taCenter;
    property ForceCaptionColor : boolean read FFCC write FFCC default True;
  end;

type
  DisplayType = (dtTime, dtDate);
  DisplaySet = set of DisplayType;
  TNCClock = class(TNCLabel)
  private
    { Private declarations }
    FTimer : TTimer;
    FDisplay : DisplaySet;
    FAlarmSet : boolean;
    FAlarm : TDateTime;
    procedure TimerEventHandler(Sender : TObject);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure RePaint; override;
    procedure EnableTimer;
    procedure DisableTimer;
  published
    { Published declarations }
    property Width default 60;
    property Display : DisplaySet read FDisplay write FDisplay;
  end;


procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Misc.', [TNCButton, TNCBlank]);
  RegisterComponents('Misc.', [TNCLabel, TNCClock]);
end;

{ ---=== Methods for TNCBlank ===---}

constructor TNCBlank.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Width := 20;
  Position := bpRight;
  DragBy := True;
end;

procedure TNCBlank.RePaint;
begin
  GetWindowRect(ParentHandle,ParentRect);
  PosLeft := GetPos;
  PosRight := PosLeft + Width;
end;

{ ---=== Methods for TNCButton ===---}
{ Public }
constructor TNCButton.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FGlyph := TBitmap.Create;
  FGlyph.Handle := LoadBitmap(HInstance,'BLANK');
  MouseCapture := False;
  Position := bpRight;
  FButtonLock := False;
  width := 20;
end;

destructor TNCButton.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

procedure TNCButton.LButton(ButtonState : TNCClickState);
begin
  if BorderValid then
  begin
    if FButtonLock then
    { If Button is a has ButtonLock }
    begin
      case ButtonState of
      csDown   : begin
                   if ButtonDown then
                   begin
                     Paint(True);
                     ButtonDown := False;
                     ButtonUnClicked;
                   end
                   else
                   begin
                     Paint(False);
                     ButtonDown := True;
                     ButtonClicked;
                   end;
                 end;
      end;
    end
    else
    { If Button is Normal }
    begin
      Paint(ButtonState = csUp);
      if ButtonState = csUp then
      begin
        MouseCapture := False;
        ReleaseCapture;
        if MouseOnGlyph then ButtonClicked;
      end
      else { down }
      begin
        MouseOnGlyph := True;
        MouseCapture := True;
        SetCapture(ParentHandle);
      end;
    end;
  end;
end;

procedure TNCButton.MouseMove(MouseX,MouseY : integer);
begin
  if BorderValid and not(FButtonLock) then
  begin
    if IsCovered(MouseX,MouseY) then
    begin
      if not(MouseOnGlyph) then Paint(False);
      MouseOnGlyph := True;
    end
    else
    begin
      if MouseOnGlyph then Paint(True);
      MouseOnGlyph := False;
    end;
  end;
end;

procedure TNCButton.RePaint;
var
  P : TPoint;
begin
  if BorderValid then
  begin
    if FButtonLock and MouseCapture then
      Paint(False)
    else
    begin
      GetCursorPos(P);
      if MouseCapture and IsCovered(P.X-ParentRect.Left,
                            P.Y-ParentRect.Top) then
        Paint(False)
      else
        Paint(True);
    end;
  end;
end;

{ Private }
procedure TNCButton.Paint(Up : boolean);
var
  WndDC,BmDC : hDC;
  OldBmp : HBitmap;
  Pos : integer;
begin
  GetWindowRect(ParentHandle,ParentRect);
  Pos := GetPos;
  WndDC := GetWindowDC(ParentHandle);
  BmDC := CreateCompatibleDC(WndDC);
  OldBmp := SelectObject(BmDC,FGlyph.Handle);
  if Up then
    BitBlt(WndDC,Pos,VerticalOffSet,Width,CaptionHeight,bmDC,0,0,SRCCOPY)
  else
    BitBlt(WndDC,Pos,VerticalOffSet,Width,CaptionHeight,bmDC,Width,0,SRCCOPY);
  SelectObject(bmDC,OldBmp);
  DeleteDC(bmDC);
  ReleaseDC(ParentHandle,WndDC);
  PosLeft := Pos;
  PosRight := Pos+Width;
end;

procedure TNCButton.ButtonClicked;
begin
  if Assigned(FOnClick) then FOnClick(Self);
end;

procedure TNCButton.ButtonUnClicked;
begin
  if Assigned(FOnUnClick) then FOnUnClick(Self);
end;

procedure TNCButton.SetGlyph(Value : TBitmap);
begin
  if FGlyph <> Value then FGlyph.Assign(Value);
end;

{ ---=== Methods for TNCLabel ===---}
constructor TNCLabel.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Position := bpRight;
  TextAlign := taCenter;
  TextColor := clCaptionText;
  BackgroundColor := clActiveCaption;
  Width := 100;
  ForceCaptionColor := True;
end;

procedure TNCLabel.SetCaption(Value: TCaption);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    Repaint;
  end;
end;

function TNCLabel.GetCaption : TCaption;
begin
  Result := FCaption;
end;

procedure TNCLabel.SetFTextColor(Value : TColor);
begin
  if Value <> FTextColor then
    FTextColor := Value;
end;

procedure TNCLabel.SetFBkColor(Value : TColor);
begin
  if Value <> FBkColor then
    FBkColor := Value;
end;

procedure TNCLabel.SetTextAlign(Value : TTextAlign);
begin
  case Value of
    taLeft       : FTextAlign := 0;
    taCenter     : FTextAlign := 1;
    taRight      : FTextAlign := 2;
  end;
end;

function TNCLabel.GetTextAlign : TTextAlign;
begin
  case FTextAlign of
    0          : Result := taLeft;
    1          : Result := taCenter;
    2          : Result := taRight;
  end;
end;

procedure TNCLabel.RePaint;
begin
  if BorderValid then Paint;
end;

procedure TNCLabel.Paint;
var
  Pos,Pos1,wth : integer;
  WndDC : hDC;
  PCaption : PChar;
  R : TRect;
  TCol,BCol,OldTextColor,OldBkColor : TColorRef;
  Brush : HBrush;
begin
  GetWindowRect(ParentHandle,ParentRect);
  Pos := GetPos;
  try
    WndDC := GetWindowDC(ParentHandle);
    R.Right := Pos + Width;
    R.Left := Pos;
    R.Top := VerticalOffset;
    R.Bottom := CaptionHeight + 2;   { Ok so I dont know where this 2 comes        }
    try                              { and it probably makes this device dependant }
      GetMem(PCaption,length(Caption)+1);
      StrPCopy(PCaption,Caption);
      if ForceCaptionColor then
      begin
        if ParentActive then
        begin
          BCol := GetSysColor(Color_ActiveCaption);
          TCol := GetSysColor(Color_CaptionText);
        end
        else
        begin
          BCol := GetSysColor(Color_InActiveCaption);
          TCol := GetSysColor(Color_InActiveCaptionText);
        end;
      end
      else
      begin
        TCol := ColorToRGB(TextColor);
        BCol := ColorToRGB(BackgroundColor);
      end;
      OldTextColor := SetTextColor(WndDC,TCol);
      OldBkColor := SetBkColor(WndDC,BCol);
      Brush := CreateSolidBrush(BCol);
      FillRect(WndDC,R,Brush);
      DrawText(WndDC,PCaption,-1,R,DT_SINGLELINE or DT_VCENTER or FTextAlign);
    finally
      FreeMem(PCaption,length(Caption)+1);
      SetTextColor(WndDC,OldTextColor);
      SetBkColor(WndDC,OldBkColor);
      DeleteObject(Brush);
    end;
  finally
    ReleaseDC(ParentHandle,WndDC);
  end;
  PosLeft := R.Left;
  PosRight := R.Right;
end;

{---=== Methods for TNCClock ===---}

constructor TNCClock.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  Width := 60;
  Display := [dtTime,dtDate];
  FTimer := TTimer.Create(Self);
  FTimer.Interval := 1000; {1 second}
  FTimer.OnTimer := TimerEventHandler;
  EnableTimer;
end;

destructor TNCClock.Destroy;
begin
  FTimer.Free;
  inherited Destroy;
end;

procedure TNCClock.TimerEventHandler(Sender : TObject);
begin
  RePaint;
end;

procedure TNCClock.RePaint;
var
  CurTime : TDateTime;
  CurDate : TDateTime;
  DateStr,TimeStr : TCaption;
begin
  if FTimer.Enabled then
  begin
    CurTime := Time;
    CurDate := Date;
    DateStr := '';
    TimeStr := '';
    if dtTime in Display then TimeStr := TimeToStr(Time);
    if dtDate in Display then DateStr := DateToStr(Date);
    Caption := DateStr+' '+TimeStr;
    inherited RePaint;
  end;
end;

procedure TNCClock.EnableTimer;
begin
  { do not allow enabling of timer at design Time }
  if not(csDesigning in ComponentState) then
  begin
    FTimer.Enabled := True;
    RePaint;
  end;
end;

procedure TNCClock.DisableTimer;
begin
  FTimer.Enabled := False;
  RePaint;
end;

end.